perm filename STRING.186[MAC,LSP] blob
sn#647770 filedate 1982-03-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00021 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 STRING -*-Mode:LispPackage:SILowercase:T-*-
C00008 00003
C00010 00004
C00014 00005
C00016 00006
C00022 00007
C00025 00008
C00029 00009
C00033 00010
C00053 00011
C00057 00012
C00062 00013
C00066 00014
C00069 00015
C00074 00016
C00078 00017
C00080 00018
C00083 00019
C00091 00020
C00095 00021
C00098 ENDMK
C⊗;
;;; STRING -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *************************************************************************
;;; *** NIL ***** Functions for STRINGs and CHARACTERs **********************
;;; *************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
;;; *************************************************************************
;;; Provides support for NIL string operations under maclisp, with
;;; most LISPM STRING functions added for compatibility.
;;; To read this file in on LISPM, do (PACKAGE-DECLARE * SYSTEM 100)
(herald STRING /186)
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload SHARPCONDITIONALS)
)
;;; CHARACTER support:
;;; m CHARACTERP, *:CHARACTER-TO-FIXNUM, *:FIXNUM-TO-CHARACTER
;;; m TO-CHARACTER, TO-CHARACTER-N,
;;; DIGITP, DIGIT-WEIGHT
;;; +m CHARACTER,
;;; +* CHAR-EQUAL, CHAR-LESSP,
;;; & |+internal-tilde-macro/|| (can be set onto } as readmacro)
;;; & USERATOMS-HOOK->CHARACTER-CLASS FLATSIZE->CHARACTER-CLASS
;;; STRING support:
;;; m STRINGP, CHAR, RPLACHAR
;;; m STRING-LENGTH, STRING-SEARCHQ, STRING-BSEARCHQ
;;; SET-STRING-LENGTH, STRING-REMQ
;;; MAKE-STRING, STRING-SUBSEQ, STRING-MISMATCHQ, STRING-HASH
;;; * CHAR-N, RPLACHAR-N, STRING-FILL, STRING-FILL-N, STRING-REPLACE
;;; * STRING-POSQ, STRING-BPOSQ, STRING-POSQ-N, STRING-BPOSQ-N
;;; * STRING-SKIPQ, STRING-BSKIPQ, STRING-SKIPQ-N, STRING-BSKIPQ-N
;;; +m STRING-EQUAL, STRING-LESSP, STRING-SEARCH, STRING-REVERSE-SEARCH
;;; +m STRING-DOWNCASE, STRING-UPCASE
;;; + GET-PNAME, SUBSTRING, STRING-APPEND, STRING-REVERSE, STRING-NREVERSE
;;; + STRING-TRIM, STRING-LEFT-TRIM, STRING-RIGHT-TRIM
;;; +* CHAR-DOWNCASE, CHAR-UPCASE,
;;; +* STRING-SEARCH-CHAR, STRING-SEARCH-NOT-CHAR,
;;; +* STRING-SEARCH-SET, STRING-SEARCH-NOT-SET
;;; +* STRING-REVERSE-SEARCH-CHAR, STRING-REVERSE-SEARCH-NOT-CHAR,
;;; +* STRING-REVERSE-SEARCH-SET, STRING-REVERSE-SEARCH-NOT-SET
;;; & STRING-PNGET, STRING-PNPUT, |+internal-doublequote-macro/||
;;; & USERATOMS-HOOK->STRING-CLASS EQUAL->STRING-CLASS
;;; & FLATSIZE->STRING-CLASS PURCOPY->STRING-CLASS
;;; & NAMESTRING->STRING-CLASS SXHASH->STRING-CLASS
;;; & EXPLODE->STRING-CLASS SAMEPNAMEP->STRING-CLASS
;;; & ALPHALESSP->STRING-CLASS LESSP->STRING-CLASS
;;; & GREATERP->STRING-CLASS
;;; &* +INTERNAL-CHAR-N, +INTERNAL-RPLACHAR-N, +INTERNAL-STRING-WORD-N
;;; &* STR/:CLEAR-WORDS, STR/:COMPARE-WORDS, STR/:GRAB-PURSEG,
;;; (a "m" is for lines whose routines are implemnted as both macros and
;;; subrs - macro definition is active only in the compiler)
;;; (a + is for lines whose routines are directly LISPM compatible -
;;; many other such routines can be written using the NIL primitives)
;;; (an * is for lines whose routines have been written in MIDAS -
;;; primarily for speed - and are in the file STRAUX >)
;;; (a & is for lines whose routines are PDP10-specific, and are
;;; primarily for internal support)
;;; (the functions named "...-N" use ascii numerical values for their
;;; arguments which are interpreted as "CHARACTER"s, instead of the
;;; new datatype "CHARACTER" - thus while STRING-POSQ scans for a
;;; particular character in a string, STRING-POSQ-N wants its character
;;; as a fixnum.)
; ---------
;A "STRING" is a 4-hunk, with | 1 | 0 |
; indices as indicated in the ---------
; diagram. | 3 | 2 |
; ---------
; (cxr 0 s) ;ptr to class object for STRINGs
; (cxr 1 s) ;"**SELF-EVAL**"
; (cxr 2 s) ;word-index in STR:ARRAY of first word of packed ascii
; (cxr 3 s) ;length of string, in characters
;;;; Out-of-core loading, and DECLAREs
#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "STRINGP")
;; well, hundreds more! (globalize )
)
#+(local MacLISP)
(declare (own-symbol MAKE-STRING STRINGP *:FIXNUM-TO-CHARACTER
|+internal-doublequote-macro/|| STRING-PNPUT))
#-NIL
(eval-when (eval compile)
;; SUBSEQ also downloads EXTEND
(subload SUBSEQ)
(subload EXTMAC)
(subload EXTBAS)
(subload SETF)
(subload DEFSETF)
(subload EVONCE)
(subload LOOP)
#M (cond ((status feature COMPLR)
(*lexpr NIL-INTERN SYMBOLCONC TO-STRING)
(*expr STRINGP *:FIXNUM-TO-CHARACTER )
#+PDP10 (*expr STRING-PNGET STRING-PNPUT)
(setq STRT7 'T)))
(setq-if-unbound *:bits-per-character #Q 8 #-Lispm 7)
(setq-if-unbound *:bytes-per-word #+Multics 4 #M 5 #Q 4)
)
#M
(defmacro (/" defmacro-for-compiling () defmacro-displace-call () )
(x)
(if (not (symbolp x)) (error '|Uluz - /" pseudo-string maker|))
#+PDP10
(progn (setq x (copysymbol x () ))
(set x x)
(putprop x `(SPECIAL ,x) 'SPECIAL)
(putprop x 'T '+INTERNAL-STRING-MARKER))
x)
#-NIL
(eval-when (eval load compile)
(let ((x (get 'ERRCK 'VERSION)))
(cond ((null x))
((alphalessp x (/" /30))
(remprop 'ERRCK 'VERSION)
(let (FASLOAD) #%(subload ERRCK))))
;; Need CLASS-OF, SEND etc, for things to work
(subload EXTEND)
(cond ((and (setq x (get 'SUBSEQ 'VERSION))
(alphalessp x (/" /39)))
(remprop 'SUBSEQ 'VERSION)
(let (FASLOAD) #%(subload SUBSEQ)))
;; Following is basically a bunch of DEF-OR-AUTOLOADABLE's
((null x)
(mapc #'(lambda (x)
(or (getl x '(SUBR LSUBR AUTOLOAD))
(putprop x #%(autoload-filename SUBSEQ) 'AUTOLOAD)))
'(TO-CHARACTER TO-CHARACTER-N? TO-STRING TO-UPCASE
TO-SYMBOL SUBSEQ REPLACE SI/:REPLACER)))))
(cond (#M (status feature COMPLR) #Q 'T
(special CHARACTER-CLASS
|+internal-CHARACTER-table/||
STRING-CLASS
STR/:NULL-STRING)
#M (progn (fixnum (STRING-LENGTH)
(CHAR-N () fixnum)
(CHAR-DOWNCASE fixnum)
(CHAR-UPCASE fixnum))
(notype (RPLACHAR-N () fixnum fixnum))
#+PDP10 (progn (fixnum (+INTERNAL-CHAR-N () fixnum)
(+INTERNAL-STRING-WORD-N () fixnum))
(notype (+INTERNAL-RPLACHAR-N () fixnum fixnum)
(+INTERNAL-SET-STRING-WORD-N () fixnum fixnum)
(SET-STRING-LENGTH () fixnum))
(fixnum STR/:GRAB-PURSEG))
(*lexpr MAKE-STRING
STRING-SKIPQ STRING-BSKIPQ STRING-SKIPQ-N
STRING-BSKIPQ-N STRING-POSQ STRING-BPOSQ
STRING-POSQ-N STRING-BPOSQ-N STRING-FILL
STRING-FILL-N STRING-SEARCH-SET
STRING-REVERSE-SEARCH-SET STRING-SEARCH-NOT-SET
STRING-REVERSE-SEARCH-NOT-SET STRING-SEARCH-CHAR
STRING-REVERSE-SEARCH-CHAR STRING-SEARCH-NOT-CHAR
STRING-REVERSE-SEARCH-NOT-CHAR STRING-REPLACE
STRING-SUBSEQ STRING-MISMATCHQ STRING-REMQ
SUBSTRING STRING-APPEND )
(array* (FIXNUM (STR/:ARRAY ()))))
))
)
#-LISPM
(eval-when (eval load compile)
(cond ((status feature COMPLR)
(special |STR/:STRING-SEARCHer|
|STR/:STRING-POSQ-Ner|
|STR/:STRING-POSQer|
STR/:STRING-EQUAL-LESSP
STR/:STRING-UP-DOWN-CASE)
#M (*lexpr |STR/:STRING-SEARCHer|
STR/:STRING-EQUAL-LESSP
STR/:STRING-UP-DOWN-CASE)
#-Multics (*expr GET-PNAME) ))
)
#M
(declare
(ARRAY* (NOTYPE (STR/:GCMARRAY)))
(*EXPR STR/:GC-DAEMON)
(SPECIAL STRINGS-GCSIZE STRINGS-GCMAX STRINGS-GCMIN)
(SPECIAL
STR/:ARRAY ;fixnum array, holding packed ascii for strings
STR/:ARYSIZE ;current size of above array, in words
STR/:FREESLOT ;slot in array above which no strings stored
STR/:GCMARRAY ;non-GC-marked s-exp array - holds all strings
STR/:GCMSIZE ;current size of above array, in "entries"
STR/:NO/.STRS ;number of strings currently entered in arrays
STR/:DUMMY ;dummy header used during string relocations
)
(SPECIAL STR/:PURE-ADDR
STR/:NO/.PWDSF
STR/:STRING-HUNK-PATTERN
STR/:CHARACTER-HUNK-PATTERN
STR/:CHARACTER-EXTEND-PATTERN )
)
#-NIL (eval-when (eval compile load)
(DEFCLASS* STRING STRING-CLASS SEQUENCE-CLASS)
(DEFCLASS* CHARACTER CHARACTER-CLASS OBJECT-CLASS)
)
(define-loop-path (characters character)
si:loop-sequence-elements-path
(of from to below above downto in by)
char string-length string character)
;;;; Temporary macros
(eval-when (compile)
(setq defmacro-for-compiling () defmacro-displace-call () )
)
(defmacro EXCH (x y) `(PSETQ ,x ,y ,y ,x))
;; For getting and setting stack args
(defmacro S-ARG (w i)
#N `(VREF ,w ,i)
#M `(ARG (1+ ,i))
#Q `(NTH ,i ,w)
)
(defmacro S-SETARG (w i val)
#N `(VSET ,w ,i ,val)
#M `(SETARG (1+ ,i) ,val)
#Q `(RPLACA (NTHCDR ,i ,w) ,val)
)
#M (progn 'compile
(defmacro AR-1 (&rest w) `(ARRAYCALL T ,. w))
#+PDP10 (progn 'compile
(defmacro NEW-CHARACTER (i &optional purep)
`(LET ((I ,i)
(C ,(cond (purep `(PURCOPY STR/:CHARACTER-HUNK-PATTERN))
('T `(SUBST () () STR/:CHARACTER-HUNK-PATTERN)))))
(SETF (SI:EXTEND-CLASS-OF C)
(SI:EXTEND-CLASS-OF STR/:CHARACTER-EXTEND-PATTERN))
(SETF (SI:EXTEND-MARKER-OF C)
(SI:EXTEND-MARKER-OF STR/:CHARACTER-EXTEND-PATTERN))
(SI:XSET C 0 (MUNKAM I))))
(defmacro NEW-STRING (wordno len)
`(SI:EXTEND STRING-CLASS ,wordno ,len))
)
#-PDP10 (progn 'compile
(defmacro NEW-CHARACTER (i &optional purep) `(SI:EXTEND CHARACTER-CLASS ,i))
(defmacro +INTERNAL-CHAR-N (&rest w) `(CHAR-N ,.w))
(defmacro +INTERNAL-RPLACHAR-N (&rest w) `(RPLACHAR-N ,.w))
)
) ;end of #M
(defmacro SUBSTRINGIFY (str i cnt)
#+Multics `(SUBSTR ,str ,i ,cnt)
#-Multics `(STRING-REPLACE (MAKE-STRING ,cnt) ,str 0 ,i ,cnt)
)
#M (progn 'compile
(defmacro DEFLEXPRMACRO (name fun first-arg args-prop &aux (g (gensym)))
`(PROGN 'COMPILE
(AND (STATUS FEATURE COMPLR)
(EVAL '(DEFMACRO ,name (&REST W)
`(,',fun ,',first-arg ,. W))))
(DEFUN ,name ,g
,g
(|*lexpr-funcall-1| ',name ,fun ,first-arg ,args-prop))))
) ;end of #M
#-MacLISP
(defmacro DEFLEXPRMACRO (name fun first-arg args-prop &aux g)
(si:gen-local-var g)
`(DEFUN ,name (&REST ,g)
(LEXPR-FUNCALL ,fun ,first-arg ,g)))
#-NIL
(defmacro DEFMUMBLE (&rest w) `(DEFLEXPRMACRO ,.w))
;;; In real NIL, defmumble generates a DEFUN which "passes along" a call
;;; to a specific sequence function, as a mini-subr call either with or
;;; without the optional "CNT" argument, depending on whether it was
;;; provided by the source code caller. This strategy allows defaulting
;;; any other optional argument to 0, but permits the mini-subr to
;;; calculate the default for the "count" argument.
#+NIL
(defmacro (DEFMUMBLE defmacro-for-compiling () )
(name () () args
&aux (cntp (si:gen-local-var () "Cntp"))
(opt-args (list (si:gen-local-var () "&opt")))
(req-args (mapcar #'(lambda (x) (si:gen-local-var () "Req-Var"))
(make-list (car args)))) )
(do ((i (1- (cdr args)) (1- i))
(opt-argsl `(,(car opt-args) 0 ,cntp)))
((<= i (car args))
`(DEFUN ,name (,@req-args &OPTIONAL ,@opt-argsl)
(COND (,cntp (,name ,@req-args ,opt-args))
(#T (,name ,@req-args
,(nreverse (cdr (reverse opt-args))))))))
(push (si:gen-local-var () "&opt") opt-args)
(push `(,(car opt-args) 0) opt-argsl)))
(eval-when (compile)
(setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED )
)
;;;; Initial setups
#+PDP10
(cond ((and (get 'STRAUX 'VERSION)
(eq (array-type 'STR/:ARRAY) 'FIXNUM)
(fixp (array-/#-dims 'STR/:GCMARRAY))))
('T (mapc '(lambda (x y) (and (not (boundp x)) (set x y)))
'(STRINGS-GCSIZE STRINGS-GCMAX STRINGS-GCMIN)
'(2048. 20480. .2))
(setq STR/:ARYSIZE STRINGS-GCSIZE
STR/:GCMSIZE 256.
STR/:FREESLOT 0
STR/:NO/.STRS 0
STR/:NO/.PWDSF 0
STR/:PURE-ADDR -1 )
(setq STR/:STRING-HUNK-PATTERN (new-string -1 0))
(setf (SI:extend-marker-of STR/:STRING-HUNK-PATTERN) () )
(setf (SI:extend-class-of STR/:STRING-HUNK-PATTERN) () )
(setq STR/:CHARACTER-EXTEND-PATTERN
(SI:EXTEND CHARACTER-CLASS (MUNKAM #O777777))
STR/:CHARACTER-HUNK-PATTERN
(SI:EXTEND CHARACTER-CLASS (MUNKAM #O777777)))
(setf (si:extend-marker-of STR/:CHARACTER-HUNK-PATTERN) () )
(setf (si:extend-class-of STR/:CHARACTER-HUNK-PATTERN) () )
(array STR/:ARRAY FIXNUM STR/:ARYSIZE)
(array STR/:GCMARRAY () STR/:GCMSIZE)
(mapc '(lambda (x) (set x (get x 'ARRAY)))
'(STR/:ARRAY STR/:GCMARRAY))
;; (setq STR/:NULL-STRING (make-string 0))
((lambda (x y)
(store (STR/:GCMARRAY 0) y)
(setq STR/:FREESLOT 1
STR/:NO/.STRS 1
STR/:NULL-STRING y)
(setq STR/:DUMMY (new-string 0 0))
(nointerrupt x))
(nointerrupt 'T)
(new-string 0 0))
(cond ((getddtsym 'GRBPSG))
((status feature ITS)
(cond ((eq (status lispv) '/1914)
(defprop GRBPSG 19042. SYM))
((valret '|:symlod/
:vp |))))
;; On non-ITS systems, make the PURE←STRING loader bomb
;; out by doing a THROW
('T (putprop 'GRBPSG (1- (getddtsym 'ERUNDO)) 'SYM)))
(subload STRAUX)))
;;;; Bothmacros and lexprmacros
#-NIL (progn 'COMPILE
(defbothmacro CHARACTERP (x) `(EQ (PTR-TYPEP ,x) 'CHARACTER))
#M
(defbothmacro STRINGP (x) `(EQ (PTR-TYPEP ,x) 'STRING))
#+Multics
(defbothmacro STRING-LENGTH (x) `(STRINGLENGTH ,x))
(defcomplrmac CHAR (str i)
`(*:FIXNUM-TO-CHARACTER (+INTERNAL-CHAR-N ,str ,i)))
(defun CHAR (str i)
(if *RSET
(let ((cnt 1))
(check-subsequence (str i cnt) 'STRING 'CHAR)))
(char str i))
(defcomplrmac RPLACHAR (str i c)
`(+INTERNAL-RPLACHAR-N ,str ,i (*:CHARACTER-TO-FIXNUM ,c)))
(defun RPLACHAR (str i c)
(cond ((or *RSET
(not (stringp str))
(not (fixnump i))
(< i 0)
(>= i (string-length str)))
(let ((cnt 1))
(check-subsequence (str i cnt) 'STRING 'RPLACHAR))
(check-type c #'CHARACTERP 'RPLACHAR)))
(rplachar str i c))
)
(defbothmacro CHARACTER (c) `(TO-CHARACTER-N? ,c () ))
#M
(progn 'compile
(defbothmacro *:CHARACTER-TO-FIXNUM (c) `(MAKNUM (SI:XREF ,c 0)))
(defbothmacro STRING-LENGTH (x) `(SI:XREF ,x 1))
;; (defbothmacro SET-STRING-LENGTH (x n) `(SI:XSET ,x 1 ,n))
;; SET-STRING-LENGTH has been re-written as a subr -- see near MAKE-STRING
(defsetf STRING-LENGTH ((() str) len) ()
`(SI:XSET ,str 1 ,len))
) ;end of #M
#+(or LISPM MULTICS)
(progn 'compile
(defbothmacro *:CHARACTER-TO-FIXNUM (VAL) `(AR-1 ,val 1))
(defbothmacro CHAR-N (H N) `(AR-1 ,h ,n))
(defbothmacro RPLACHAR-N (H N VAL)
(cond ((or (|side-effectsp/|| h)
(|side-effectsp/|| n)
(|side-effectsp/|| val))
(let (htem tmp)
(si:gen-local-var htem (/" |Char|))
(si:gen-local-var tmp (/" I))
`((LAMBDA (,htem ,tmp) (AS-1 ,val ,htem ,tmp))
,h ,n)))
(`(AS-1 ,val ,h ,n))))
(defbothmacro SET-STRING-LENGTH (x n) `(ADJUST-ARRAY-SIZE ,x ,n))
(defsetf STRING-LENGTH ((() str) len) ()
`(SET-STRING-LENGTH ,str ,len))
) ;end of #+(or LISPM MULTICS)
;; STRING-SEARCHQ AND STRING-EQUAL are already mini-subr'd in real NIL
#-NIL
(defmumble STRING-SEARCHQ |STR/:STRING-SEARCHer|
'(() T STRING-SEARCHQ) '(2 . 4))
(defmumble STRING-BSEARCHQ |STR/:STRING-SEARCHer|
'(() () STRING-BSEARCHQ) '(2 . 4))
#-LISPM (progn 'compile
;;; STRING-EQUAL and STRING-LESSP should be rewritten in machine lang?
(deflexprmacro STRING-LESSP STR/:STRING-EQUAL-LESSP '(() . () ) '(2 . 6))
#-NIL
(deflexprmacro STRING-EQUAL STR/:STRING-EQUAL-LESSP '(() . T) '(2 . 6))
(deflexprmacro STRING-SEARCH |STR/:STRING-SEARCHer|
'(T T STRING-SEARCH) '(2 . 4))
(deflexprmacro STRING-REVERSE-SEARCH |STR/:STRING-SEARCHer|
'(T () STRING-REVERSE-SEARCH) '(2 . 4))
(deflexprmacro STRING-DOWNCASE STR/:STRING-UP-DOWN-CASE () '(1 . 3))
(deflexprmacro STRING-UPCASE STR/:STRING-UP-DOWN-CASE #T '(1 . 3))
) ;end of #-LISPM
#-PDP10 ;These come in from the STRAUX file for maclisp
(progn 'compile
#-NIL
(defmumble STRING-POSQ |STR/:STRING-POSQer| '(POSQ . T) '(2 . 4))
(defmumble STRING-BPOSQ |STR/:STRING-POSQer| '(POSQ . () ) '(2 . 4))
#-NIL
(defmumble STRING-SKIPQ |STR/:STRING-POSQer| '(SKIPQ . T) '(2 . 4))
(defmumble STRING-BSKIPQ |STR/:STRING-POSQer| '(SKIPQ . () ) '(2 . 4))
#-NIL
(defmumble STRING-POSQ-N |STR/:STRING-POSQ-Ner| '(POSQ . T) '(2 . 4))
(defmumble STRING-BPOSQ-N |STR/:STRING-POSQ-Ner| '(POSQ . () ) '(2 . 4))
#-NIL
(defmumble STRING-SKIPQ-N |STR/:STRING-POSQ-Ner| '(SKIPQ . T) '(2 . 4))
(defmumble STRING-BSKIPQ-N |STR/:STRING-POSQ-Ner| '(SKIPQ . () ) '(2 . 4))
#-NIL
(defmumble STRING-FILL |STR/:STRING-POSQer| '(FILL . () ) '(2 . 4))
#-NIL
(defmumble STRING-FILL-N |STR/:STRING-POSQ-Ner| '(FILL . () ) '(2 . 4))
) ;end of #-PDP10
(defsetf CHAR ((() frob index) value) ()
`(RPLACHAR ,frob ,index ,value))
(defsetf CHAR-N ((() frob index) value) ()
`(RPLACHAR-N ,frob ,index ,value))
;;;; Maclisp MAKE-STRING and gc support, and buck-passing |*lexpr-funcall-1|
#+PDP10
(progn 'compile
(eval-when (eval compile)
(defmacro WORD-NO (str) `(SI:XREF ,str 0))
;; Warning! Discontinuity at 0: (// -1 5) => -1, instead of 0
(defsimplemac NO-WORDS-USED (x)
`(IF (<= ,x 0) 1 (1+ (// (1- ,x) #.*:bytes-per-word))))
(defsimplemac WORDNO-OF-NEXT-FREESLOT (str)
`(+ (WORD-NO (STR/:GCMARRAY ,str))
(NO-WORDS-USED (FIXNUM-IDENTITY (STRING-LENGTH ,str)))))
(defmacro TRIMWORD (word no-odd-chrs)
`(DEPOSIT-BYTE ,word
0
(1+ (* (- #.*:bytes-per-word ,no-odd-chrs)
#.*:bits-per-character))
0))
)
(defconst STR/:GC-DAEMON ()
"Flag used to communicate the fact that the gc-daemon has been run.")
(defun MAKE-STRING (x &optional (filler 0 fillerp))
(if (or (not (fixnump x)) (< x 0))
(check-type x #'SI:NON-NEG-FIXNUMP 'MAKE-STRING))
(prog (wds-required maxslot n no-strings str oni cfl gfl *RSET)
(declare (fixnum n wds-required no-strings maxslot))
(setq oni (nointerrupt 'T)
n x
wds-required (no-words-used n))
A (setq maxslot (+ wds-required STR/:FREESLOT))
(cond
((>= maxslot STR/:ARYSIZE)
;;Do we need GC or COMPRESSION attention?
(cond ((< maxslot STRINGS-GCSIZE)
;;Maybe we could just grow the array without GC'ing?
(str/:grow-array maxslot))
((null cfl)
;;Try compressing without GC at least once.
(STR/:COMPRESS-SPACE () )
(setq cfl 'T)
(go A))
((null gfl)
;;Well, try Gc'ing once, and (maybe) permit interrupts
(nointerrupt oni)
(setq STR/:GC-DAEMON () )
(gc)
;;Must have GC-DAEMON run, to mark STR/:GCMARRAY
(if (null STR/:GC-DAEMON) (str/:gc-daemon () ))
(nointerrupt 'T)
(STR/:COMPRESS-SPACE () )
(str/:grow-array maxslot)
(setq gfl 'T cfl 'T)
(go A))
('T (error (/" |Can't get enough STRING space|)
wds-required
'FAIL-ACT)
(setq gfl () cfl () )
(go A)))))
;; Here is the basic consification of strings!
(setq no-strings (setq STR/:NO/.STRS (1+ STR/:NO/.STRS)))
(cond ((> no-strings STR/:GCMSIZE )
(nointerrupt oni)
(let ((newsize (+ STR/:GCMSIZE 512.)))
(*rearray 'STR/:GCMARRAY () newsize)
(setq STR/:GCMSIZE newsize))
(nointerrupt 'T)))
(setq str (new-string STR/:FREESLOT n)
STR/:FREESLOT (+ STR/:FREESLOT wds-required))
(store (STR/:GCMARRAY (1- no-strings)) str)
(nointerrupt oni)
(if (or (null fillerp) (= filler 0))
(str/:clear-words str wds-required)
(string-fill-n str (character filler)))
(return str)))
(defun STR/:GROW-ARRAY (maxslot)
;; Calculate a size to which the array ought to be grown.
(setq maxslot
(+ maxslot
(cond ((fixnump STRINGS-GCMIN) STRINGS-GCMIN)
((flonump STRINGS-GCMIN)
(ifix (*$ STRINGS-GCMIN (float STR/:ARYSIZE))))
('T 1024.))))
(*rearray 'STR/:ARRAY 'FIXNUM maxslot)
(setq STR/:ARYSIZE (array-dimension-n 1 'STR/:ARRAY))
(if (< STRINGS-GCSIZE STR/:ARYSIZE)
(setq STRINGS-GCSIZE STR/:ARYSIZE))
(if ↑D
(let ((OUTFILES (if (memq 'T msgfiles)
(cons tyo msgfiles)
msgfiles))
(↑R 'T) (↑W 'T)
(BASE 10.) (*NOPOINT))
(terpri)
(princ '|;Adding a new STRING chunk -- space is now |)
(prin1 STR/:ARYSIZE)
(princ '| words.|)))
'T)
(eval-when (eval compile)
(defsimplemac GCDAEMON-LOST? (str)
`(OR (NOT (EQ (TYPEP ,str) ',(typep (new-string -1 0))))
(AND (CXR 1 ,str) ;GC nullifies LH of hunk
(NOT (EQ (SI:EXTEND-CLASS-OF ,str) STRING-CLASS))
(NOT (EQ (TYPE-OF ,str) 'STRING)))))
)
(defvar STR/:GC-CHECK? () )
;;; If non-null, causes the weird condition of non-string-found-in-string-array
;;; to breakpoint. Whether breaking or not, the conditions is proceedable
;;; merely by nullifying the offending slot.
(defun STR/:GC-CHECK? (msg fun i flushp errorp)
(cond ((or STR/:GC-CHECK? errorp)
(format msgfiles
(/" |;Possible STRING bug: }A}%; Discovered in }A }:[-- Returning will merely flush (STR/:GCMARRAY }d)}]|)
(or msg (/" |Non-string in GCMARRAY|))
fun
(not flushp)
i)
(let ((BREAK i))
(declare (special BREAK))
(break STR/:GC-CHECK?))))
(if (not (fixnump i)) (+internal-lossage 'FIXNUM 'STR/:GC-CHECK? i))
(and flushp (store (STR/:GCMARRAY i) () )))
(defun STR/:COMPRESS-SPACE (recursivep)
;; *RSET is () when MAKE-STRING calls this function, but most
;; importantly, (NOINTERRUPT 'T) has been done, so there can't be
;; any re-entrant calls!!!
(do ((i 1 (1+ i))
(lui 0) ;last used index
(free-loc 1) (str-ln 0)
(current-loc 0) (old-loc 0)
(byte-parity 0) (lowest-i-certified-safe 0)
(str)
(str-free STR/:DUMMY))
((> i STR/:NO/.STRS) ;Loop thru the GCMARRAY
(if ↑D
(let ((OUTFILES (if (memq 'T msgfiles)
(cons tyo msgfiles)
msgfiles))
(n (1+ lui))
(↑R 'T) (↑W 'T)
(BASE 10.) (*NOPOINT))
(declare (fixnum n))
(terpri)
(princ '|;Compression of STRING space: |)
(prin1 n)
(princ '| live Strings, using |)
(prin1 free-loc)
(princ '| words.|)
(terpri)
(cond ((not (= 0 (setq n (- STR/:NO/.STRS n))))
(princ '|; (Reclaimed |)
(prin1 n)
(princ '| strings using |)
(prin1 (- STR/:FREESLOT free-loc))
(princ '| words.)|))
('T (print '|; (Nothing reclaimed).|)))))
(setq STR/:NO/.STRS (1+ lui) ; # strs still alive
STR/:FREESLOT free-loc) ;lowest free in STR:ARRAY
() )
(declare (fixnum i lui free-loc str-ln current-loc old-loc
byte-parity lowest-i-certified-safe))
(setq str (STR/:GCMARRAY i))
(cond ((null str) () ) ;String already proven dead
((gcdaemon-lost? str)
(str/:gc-check? () 'STR/:COMPRESS-SPACE i 'T () ))
((or (< (setq str-ln (string-length str)) 0)
(> str-ln 1←14.)
(< (setq current-loc (word-no str)) 0)
(> current-loc 12.←14.))
(str/:gc-check? (/" |STRING length or location bad!|)
'STR/:COMPRESS-SPACE
i
'T
'T))
((>= current-loc old-loc)
;;Aha! STRING is alive!
(if (= current-loc old-loc)
(str/:gc-check? '|Failure to increment STR/:FREESLOT|
'STR/:COMPRESS-SPACE
i
()
'T))
(setf (string-length str-free) str-ln) ;Close gap, if any,
(setf (word-no str-free) free-loc) ; moving string to
(cond ((not (= str-ln 0)) ; the lower slot
(string-replace str-free str)
;;After string movement, we have have to insure
;; that final word is padded with 0's
(if (not (= (setq byte-parity (\ str-ln 5)) 0))
;;Byte-parity is 0,1,2,3,4 counting from left
(let ((ha (1- (no-words-used str-ln))))
(+internal-set-string-word-n
str-free
ha
(trimword (+internal-string-word-n
str-free
ha)
byte-parity))))))
(setf (word-no str) free-loc)
;; Update running counters for FREE-SLOTLOC and NO.STRS
(setq old-loc current-loc
free-loc (+ free-loc (no-words-used str-ln)))
(cond ((not (= (setq lui (1+ lui)) i))
(store (STR/:GCMARRAY lui) str)
(store (STR/:GCMARRAY i) () ))))
('T ;; means that (< current-loc old-loc)
;;Looks like some loser "sneaked" in here.
(if recursivep (+internal-lossage 'STR/:COMPRESS-SPACE 'STR/:COMPRESS-SPACE recursivep))
(comment ;For the time being, just ignore any extra
;processing on these losers
(let ((loser (str/:gcmarray lui)))
(str/:gc-check? (/" |Re-cons'd String found|)
'STR/:COMPRESS-SPACE
lui
'T
() )
;;Ok, just try to certify that all strings in the array
;; from 0 up to here are "unique"
(do ((k (1+ lowest-i-certified-safe) (1+ k))
(sk))
((>= k lui))
(declare (fixnum k j))
(setq sk (str/:gcmarray k))
(do ((j (1+ k) (1+ j)))
((> j STR/:NO/.STRS))
(if (eq sk (str/:gcmarray j))
(str/:gc-check? (/" |Re-cons'd String out of order?|)
'STR/:COMPRESS-SPACE k () 'T))))
;;And check out this loser -- it had better be a twice-
;; cons'd hunk used as a string again.
(do ((j i (1+ j)))
((> j STR/:NO/.STRS)
(str/:gc-check? (/" |Re-cons'd String has no 2nd instance.|)
'STR/:COMPRESS-SPACE lui () 'T))
(declare (fixnum j))
(if (eq loser (str/:gcmarray j)) (return () )))
(setq lowest-i-certified-safe lui)
(setq lui (1- lui)))
)
(do ((k 1 (1+ k))
(sk))
((>= k STR/:NO/.STRS))
;;Try to kill out any low-index entries whose hunk is being
;; used later in the GCMARRAY
(declare (fixnum k j))
(setq sk (str/:gcmarray k))
(do ((j (1+ k) (1+ j)))
((>= j STR/:NO/.STRS))
(cond ((eq sk (str/:gcmarray j))
(store (str:gcmarray k) () )
(return () )))))
;Then try again!
(str/:compress-space i)
(return () )))))
(defun STR/:GC-DAEMON (() )
;; *RSET is () when MAKE-STRING calls the GC
(cond ((not (eq STR/:NULL-STRING (STR/:GCMARRAY 0)))
(str/:gc-check? (/" |(STR/:GCMARRAY 0) clobbered|)
'STR/:GC-DAEMON
0
()
'T)
(store (STR/:GCMARRAY 0) STR/:NULL-STRING)))
(do ((i 1 (1+ i)) ;index which cycles thru gcmarray
(ns 0) ;number of non-"nullified" slots
(nn 0) ; amount of space consumed
(str) )
((> i STR/:NO/.STRS)
(if ↑D
(let ((OUTFILES (if (memq 'T msgfiles)
(cons tyo msgfiles)
msgfiles))
(↑R 'T) (↑W 'T)
(BASE 10.) (*NOPOINT))
(princ '|;STRING space: |)
(prin1 ns)
(princ '| live strings, using |)
(prin1 nn)
(princ '| words.|)
(terpri) )))
(declare (fixnum i ns nn))
(cond ((null (setq str (STR/:GCMARRAY i))) () ) ;Already flushed this one?
((null (car str))
;;GC nullifies LH of hunk, so if string is dead, then nullify
;; gcmarray slot, for it is garbage!
(store (STR/:GCMARRAY i) () ))
((gcdaemon-lost? str)
(str/:gc-check? () 'STR/:GC-DAEMON i 'T () ))
(↑D (setq ns (1+ ns)
nn (+ nn (no-words-used (string-length str)))))))
(setq STR/:GC-DAEMON 'T))
(eval-when (compile)
(notype (SET-STRING-LENGTH () () )))
(defun SET-STRING-LENGTH (str n &aux (lstr 0) (no-odd-chrs 0))
(declare (fixnum lstr no-odd-chrs))
(if (not (stringp str)) (check-type str #'STRINGP 'SET-STRING-LENGTH))
(setq lstr (string-length str))
(do ()
((and (fixnump n) (<= 0 n lstr)))
(setq n (error (/" |Can't set length of string to this|)
`(STRING str n)
'FAIL-ACT)))
(setq no-odd-chrs (\ n #.*:bytes-per-word))
(or (= no-odd-chrs 0)
(let* ((lstwd-i (1- (no-words-used n)))
(lastword (+internal-string-word-n str lstwd-i)))
(declare (fixnum lstwd-i))
(+internal-set-string-word-n
str
lstwd-i
(trimword lastword no-odd-chrs))))
(setf (string-length str) n)
str)
(eval-when (eval compile)
(defmacro LEXPR-FCL-HELPER (n)
(or (fixnump n) (error 'lexpr-fcl-helper n))
(do ((i 1 (1+ i)) (w () ))
((> i n) `(LSUBRCALL T FUN FIRST-ARG ,. (nreverse w)))
(push `(ARG ,i) w)))
)
(defun |*lexpr-funcall-1| (name fun first-arg args-prop)
;; Function for passing the buck
(let ((n (arg () )))
(and (or (< n (car args-prop)) (> n (cdr args-prop)))
(error (/" |Wrong number args to function|) name))
(caseq n
(1 (lexpr-fcl-helper 1))
(2 (lexpr-fcl-helper 2))
(3 (lexpr-fcl-helper 3))
(4 (lexpr-fcl-helper 4))
(5 (lexpr-fcl-helper 5))
(6 (lexpr-fcl-helper 6)))))
) ;end of moby #+PDP10
;;;; Some funs primitive in real NIL: *:FIXNUM-TO-CHARACTER, DIGITP, DIGITP-N
;;;; STRING-SUBSEQ, STRING-MISMATCHQ
#-NIL (progn 'compile
(defun STR/:CHARACTER-VALUEP (x) (and (fixnump x) (<= 0 x #O7777)))
(defun *:FIXNUM-TO-CHARACTER (x &aux (n 0))
(declare (fixnum n))
(and *RSET (check-type x #'STR/:CHARACTER-VALUEP '*:FIXNUM-TO-CHARACTER))
(cond ((cond ((< (setq n x) #.(↑ 2 *:bits-per-character)))
('T (and (bit-test n #O4000) ;IOR the %TXTOP bit to
(setq n (bit-set #O1000 n))) ; %TXSFT position, and
(setq n (logand #O1777 n)) ; fold down to 10. bits
(< (setq n x) #.(↑ 2 *:bits-per-character))))
(ar-1 |+internal-CHARACTER-table/|| n))
('T (setq x (munkam n))
(cdr (cond ((assq x (ar-1 |+internal-CHARACTER-table/||
#.(↑ 2 *:bits-per-character))))
('T (setq x (cons x (new-character n)))
(push x (ar-1 |+internal-CHARACTER-table/||
#.(↑ 2 *:bits-per-character)))
x))))))
(defun STRING-SUBSEQ (str i &optional (cnt () cntp))
(cond (*RSET (check-subsequence (str i cnt) 'STRING 'STRING-SUBSEQ #T cntp))
((not cntp) (setq cnt (- (string-length str) i))))
(substringify str i cnt))
;;; Someday, STRING-MISMATCHQ should be rewritten in MIDAS.
(defun STRING-MISMATCHQ (s1 s2 &optional (i1 0) (i2 0) (cnt () ocntp))
(let ((n 0) (cntp ocntp))
(declare (fixnum n))
(cond (*RSET
(let ((foo1 cnt) (foo2 cnt))
(check-subsequence (s1 i1 foo1) 'STRING 'STRING-MISMATCHQ #T cntp)
(check-subsequence (s1 i2 foo2) 'STRING 'STRING-MISMATCHQ #T cntp)
(setq n (if (< foo1 foo2) foo1 foo2)
cntp #T)))
(cntp (setq n cnt)))
(let ((ls1 (- (string-length s1) i1))
(ls2 (- (string-length s2) i2)))
(declare (fixnum ls1 ls2))
(if (not cntp) (setq n (if (< ls1 ls2) ls1 ls2)))
(cond #+PDP10
((and (= i1 0)
(= i2 0)
(= ls1 ls2)
(= n ls1)
(str/:compare-words s1 s2))
() )
(#T (do ((i 0 (1+ i)))
((>= i n)
(if (or ocntp (and (= n ls1) (= n ls2)))
()
n))
(declare (fixnum i))
(if (not (= (+internal-char-n s1 (+ i1 i))
(+internal-char-n s2 (+ i2 i))))
(return (+ i1 i)))))))))
) ;end of #-NIL
;;;; STRING-PNGET and STRING-PNPUT
#+PDP10 (progn 'COMPILE
(defun STRING-PNGET (string seven)
(cond (*RSET
(if (not (and (fixnump seven) (= seven 7)))
(error (/" |Uluz - need 7|) seven))
(check-type string #'STRINGP 'STRING-PNGET)))
(let* ((str-ln (string-length string))
(lstwd-i (1- (no-words-used str-ln)))
(no-odd-chrs (\ str-ln #.*:bytes-per-word))
(lastword (+internal-string-word-n string lstwd-i))
(wdsl `(,(if (= no-odd-chrs 0)
lastword
(trimword lastword no-odd-chrs)))))
(declare (fixnum str-ln lstwd-i no-odd-chrs lastword))
(do ((i 0 (1+ i)))
((>= i lstwd-i))
(declare (fixnum i))
(push (+internal-string-word-n string (- lstwd-i i 1)) wdsl))
wdsl))
(defun STRING-PNPUT (l () )
(do ()
((or (null l) (pairp l)))
(setq l (error (/" |Bad arg - STRING-PNPUT|) l 'WRNG-TYPE-ARG)))
(if (and l (null (cdr l)) (= (car l) 0)) (setq l () )) ;Let || ==> ""
(let* ((no/.wds (length l))
(str-ln (* no/.wds #.*:bytes-per-word))
(str (make-string str-ln)))
(declare (fixnum no/.wds str-ln))
(if l (progn
(do ((ll l (cdr ll))
(i 0 (1+ i)))
((null ll))
(declare (fixnum i))
(+internal-set-string-word-n str i (car ll)))
(let ((*RSET)
(where (string-bskipq-n 0 str (1- str-ln) #.*:bytes-per-word)))
(if where (setf (string-length str) (1+ where))))))
str))
;;;; STRING-HASH and |*lexpr-funcall-1|
(defun STRING-HASH (str &optional (start-i 0) (cnt () cntp))
(cond ((and (stringp str) ;Don't bother with complicated
(fixnump start-i) ; general error checking, if
(= start-i 0) ; the simple case obtains
(null cntp)))
(*RSET
(check-subsequence (str start-i cnt) 'STRING 'STRING-HASH #T cntp)
(setq cntp #T)))
(let ((str-ln (string-length str)))
(declare (fixnum str-ln))
(if (not cntp) (setq cnt (- str-ln start-i)))
(cond
((= cnt 0) 12345.)
(#T (if (not (= (\ start-i #.*:bytes-per-word) 0))
(setq str (string-subseq str start-i cnt) start-i 0))
(let* ((1stwd-i (// start-i #.*:bytes-per-word))
(lstwd-i (1- (no-words-used cnt)))
(no-odd-chars (\ cnt #.*:bytes-per-word))
(hash (+internal-string-word-n str (+ 1stwd-i lstwd-i))))
(declare (fixnum 1stwd-i lstwd-i no-odd-chars hash))
(or (= no-odd-chars 0)
(setq hash (trimword hash no-odd-chars)))
(do ((i (- lstwd-i 1stwd-i 1) (1- i)))
((< i 1stwd-i))
(declare (fixnum i))
(setq hash (logxor (+internal-string-word-n str i) hash)))
(lsh hash -1))))))
) ;end of #+PDP10
;;;; DIGITP, DIGIT-WEIGHT, and |STR/:STRING-SEARCHer|
(defun DIGITP (c)
(and (setq c (to-character-n? c #T))
(<= #/0 c #/9)))
(defun DIGIT-WEIGHT (c)
(setq c (to-character-n? c () ))
(cond ((<= #/0 c #/9) (- c #/0))
((<= #/A c #/Z) (- c #.(- #/A 10.)))
((<= #/a c #/z) (- c #.(- #/a 10.)))))
(defun |STR/:STRING-SEARCHer| (foo s1 s2 &optional (i2 () i2p) (cnt () cntp)
&aux (lispmp (car foo))
(fwp (cadr foo))
(fun (caddr foo)))
(cond (*RSET
(check-type s1 #'STRINGP 'STRING-SEARCH)
(check-subsequence (s2 i2 cnt) 'STRING fun i2p cntp fwp lispmp)
(setq i2p #T cntp #T)))
(prog (ls1 ls2 mpsi ss-i)
(declare (fixnum ls1 ls2 mpsi ss-i))
(setq ls1 (string-length s1)
ls2 (string-length s2)
mpsi (- ls2 ls1))
(cond ((or (not i2p) (null i2))
(setq i2 (if fwp 0 (if lispmp ls2 (1- ls2))))
(setq i2p () )))
(setq ss-i i2) ;search start index
(cond ((not fwp)
(setq ss-i (- ss-i ls1))
(if (not lispmp) (setq ss-i (1+ ss-i)))))
(return
(cond
((< mpsi 0) () )
((= ls1 0)
(if (not fwp) (setq ss-i (1- ss-i)))
ss-i)
((let ((haumany 0)
(1st-p-c (+internal-char-n s1 0)) ;First pattern char
(mnpsi 0))
(declare (fixnum haumany 1st-p-c mnpsi))
(setq haumany (1+ (if fwp (- mpsi ss-i) ss-i)))
(cond ((and cntp (< cnt haumany))
(setq haumany cnt)
(if fwp (setq mpsi (+ ss-i haumany -1)))))
(setq mnpsi (- ss-i haumany)) ;Minimum possible start index
(do ((j ss-i)
#-NIL (*RSET)
#-NIL (nxt-i) )
((cond ((null j)) ;Iterate while "next" search-
(fwp (> j mpsi)) ; start index will be within
(#T (< j mnpsi))) ; bounds.
() )
(if lispmp
(cond
((setq j
(if fwp
(string-search-char 1st-p-c s2 j)
(string-reverse-search-char 1st-p-c s2 (1+ j))))
(and (<= mnpsi j mpsi)
(string-equal s1 s2 0 j ls1 (+ j ls1))
(return j))))
#-NIL
(cond
((setq nxt-i
(cond (fwp (string-posq-n 1st-p-c s2 j haumany))
(#T (string-bposq-n 1st-p-c s2 j haumany))))
(and (<= mnpsi nxt-i mpsi)
(not (string-mismatchq s1 s2 0 nxt-i ls1))
(return nxt-i))
(setq haumany (- haumany (if fwp
(1+ (- nxt-i j))
(- j nxt-i)))))
('T (setq j () )))))
))))))
;;;; SUBSTRING, STRING-APPEND, STRING-REVERSE, STRING-NREVERSE,
;; LISPM compatibility stuff
#-LISPM
(progn 'compile
(defun SUBSTRING (str i &optional (lmi () lmip))
(cond (*RSET
;; Check as if "end-index" were a start for backwards searching
(check-subsequence (str lmi () ) 'STRING 'SUBSTRING lmip () () #T)
(check-type i #'SI:NON-NEG-FIXNUMP 'SUBSTRING))
((null lmip) (string-length str)))
(substringify str i (- lmi i)))
(defun STRING-APPEND #-NIL n #+NIL (&rest w &aux (n (vector-length w)))
(let ((new-len 0) str)
(declare (fixnum new-len))
(do ((i 0 (1+ i)))
((>= i n))
(declare (fixnum i))
(setq str (s-arg w i)) ;Calculate total length of resultant string
(cond ((not (stringp str))
(cond ((not (symbolp str))
(check-type str #'STRINGP 'STRING-APPEND))
(#T (setq str (get-pname str))))
(s-setarg w i str)))
(setq new-len (+ new-len (string-length str))))
#+Multics
(apply 'CATENATE (listify n))
#-Multics
(let ((newstr (make-string new-len))
(ii 0) ;"ii" is a running start index
*RSET)
(do ((i 0 (1+ i)))
((>= i n))
(declare (fixnum i))
(setq str (s-arg w i))
(cond ((not (= (string-length str) 0)) ;Fill in parts of new string
(string-replace newstr str ii)
(setq ii (+ ii (string-length str))))))
newstr)))
(defun STRING-REVERSE (str &optional start (cnt () cntp))
(str/:string-reverser str #T start cnt cntp))
(defun STRING-NREVERSE (str &optional start (cnt () cntp))
(str/:string-reverser str () start cnt cntp))
;;;; STR/:STRING-REVERSER STR/:STRING-EQUAL-LESSP
;;; Remember, still within a #-LISPM conditional
(defun STR/:STRING-REVERSER
(str newp start cnt cntp &aux (newstr str) (lstr 0))
(declare (fixnum lstr))
(if (null start) (setq start 0))
(cond ((or *RSET (not newp))
(check-subsequence (str start cnt)
'STRING
(if newp 'STRING-REVERSE 'STRING-NREVERSE)
#T
cntp)
(setq cntp #T lstr (string-length str))
(if newp (let (*RSET) (setq newstr (string-subseq str start cnt)))))
(#T (setq lstr (string-length str))
(cond ((not cntp) (setq cnt (- lstr start)))
((not (<= (+ start cnt) lstr))
(setq cnt (- lstr start))))
(if newp (setq newstr (string-subseq str start cnt)))))
(if newp (setq start 0))
(do ((i start (1+ i))
(ii (+ start cnt -1) (1- ii))
chii)
((> i ii) )
(declare (fixnum i ii chii))
(setq chii (+internal-char-n newstr ii)) ;Save an interchange char,
(+internal-rplachar-n newstr ii (+internal-char-n newstr i))
(+internal-rplachar-n newstr i chii)) ; and pairwise-interchange
newstr)
(defun STR/:STRING-EQUAL-LESSP
(foo s1 s2
&optional (i1 0 i1p) (i2 0 i2p) (lm1 () lm1p) (lm2 () lm2p))
(let (((nocasep . equalp) foo)
(ls1 0) (ls2 0) (c1 0) (c2 0))
(declare (fixnum ls1 ls2 c1 c2))
(cond
(*RSET
;; Check as if "end-index" were a start for backwards searching
(check-subsequence
(s1 lm1 () ) 'STRING 'STR/:STRING-EQUAL-LESSP lm1p () () #T)
(check-subsequence
(s2 lm2 () ) 'STRING 'STR/:STRING-EQUAL-LESSP lm2p () () #T)
(setq lm1p #T lm2p #T)
(if i1p (check-type i1 #'SI:NON-NEG-FIXNUMP 'STR/:STRING-EQUAL-LESSP))
(if i2p (check-type i2 #'SI:NON-NEG-FIXNUMP 'STR/:STRING-EQUAL-LESSP))
(setq c1 (- lm1 i1) c2 (- lm2 i2))
(check-subsequence (s1 i1 c1) 'STRING 'STR/:STRING-EQUAL-LESSP)
(check-subsequence (s2 i2 c2) 'STRING 'STR/:STRING-EQUAL-LESSP)
(setq ls1 (string-length s1) ls2 (string-length s2)) )
(#T (setq ls1 (string-length s1) ls2 (string-length s2)
c1 (- (if lm1p lm1 ls1) i1)
c2 (- (if lm2p lm2 ls2) i2))))
(cond
((and equalp (not (= c1 c2))) () )
((and (not equalp) (= c1 0)) (not (= c2 0)))
((do ((i1* i1 (1+ i1*)) ;Iterate over the two
(i2* i2 (1+ i2*)) ; strings, looking for
(i (if (< c1 c2) c1 c2) (1- i))) ; a place of discord
((<= i 0)
(if (or equalp (> (- lm2 i2*) (- lm1 i1*)))
#T))
(declare (fixnum i i1* i2*))
(setq c1 (+internal-char-n s1 i1*)
c2 (+internal-char-n s2 i2*))
(if (not (if nocasep (= c1 c2) (char-equal c1 c2)))
;;No decision possible when chars are "equal"
(return (cond (equalp () )
(nocasep (< c1 c2))
(#T (char-lessp c1 c2)))))) )) ))
;;; Remember, still within a #-LISPM conditional
(comment GET-PNAME STR/:STRING-UP-DOWN-CASE TRIMers)
;LISPM compatibility stuff
#+PDP10
(defun GET-PNAME (x)
(setq x (pnget x 7))
(and (null (cdr x)) ;Foo! || has (0) as pname list.
(= (car x) 0)
(setq x () ))
(string-pnput x 7))
(defun STR/:STRING-UP-DOWN-CASE (up s1 &optional i1 (cnt () cntp))
(if (null i1) (setq i1 0))
(if (symbolp s1) (setq s1 (get-pname s1)))
(cond (*RSET
(check-subsequence (s1 i1 cnt)
'STRING
(if up 'STRING-UPCASE 'STRING-DOWNCASE)
#T
cntp)
(setq cntp #T)))
(let ((ls1 (string-length s1))
(ch 0)
newstr)
(declare (fixnum ls1 ch))
(if (not cntp) (setq cnt (- ls1 i1)))
(setq newstr (make-string cnt))
(do ((i 0 (1+ i)))
((>= i cnt))
(declare (fixnum i))
(setq ch (+internal-char-n s1 (+ i i1)) ;get this char
ch (if up (char-upcase ch) (char-downcase ch))) ;case-ify it
(+internal-rplachar-n newstr i ch))
newstr))
(defun STRING-LEFT-TRIM (cl str)
(str:trim-check cl str 'T () 'STRING-LEFT-TRIM))
(defun STRING-RIGHT-TRIM (cl str)
(str:trim-check cl str () 'T 'STRING-RIGHT-TRIM))
(defun STRING-TRIM (cl str)
(str:trim-check cl str 'T 'T 'STRING-TRIM))
(defun STR:TRIM-CHECK (cl str leftp rightp fun)
(prog (i1*)
(declare (fixnum i1* i2* len))
(setq i1* 0)
(if (symbolp str) (setq str (get-pname str)))
(cond (*RSET (check-type str #'STRINGP fun)
(check-type cl #'LISTP fun)))
(if leftp
(if (setq leftp (string-search-not-set cl str))
(setq i1* leftp)
(return STR/:NULL-STRING)))
(return
(cond ((null rightp) (string-subseq str i1*))
((null (setq rightp (string-reverse-search-not-set cl str)))
STR/:NULL-STRING)
((let ((len (string-length str))
(i2* rightp))
(if (>= i2* len) (setq i2* (1- len)))
(string-subseq str i1* (- i2* i1* -1))))))))
) ;end of moby #-LISPM conditional
;;;; STRING-REMQ
(setq si:STRING-REMQ-buffer () )
#+(or NIL MacLISP)
(push 'si:STRING-REMQ-buffer #N SI:BREAK-BOUND-VARIABLES
#M +INTERNAL-INTERRUPT-BOUND-VARIABLES )
(defun STRING-REMQ (c str &optional (starti 0 ip) (cnt () cntp)
&aux (n 0) (cn 0))
(declare (fixnum ln i j cn cc maxln)
(special si:STRING-REMQ-buffer))
(or si:STRING-REMQ-buffer (setq si:STRING-REMQ-buffer (make-string 100.)))
(if *RSET
(check-subsequence (str starti cnt) 'STRING 'STRING-SUBSEQ ip cntp))
(setq n (or cnt (- (string-length str) starti))
cn (to-character-n c))
(do ((i starti (1+ i))
(j 0)
(cc 0)
(maxln (string-length si:STRING-REMQ-buffer)))
((< (setq n (1- n)) 0) (substringify si:STRING-REMQ-buffer 0 j))
(cond ((not (= cn (setq cc (+internal-char-n str i))))
(if (> j maxln)
(setq si:STRING-REMQ-buffer
(string-replace
(make-string (setq maxln (+ maxln 100.)))
si:STRING-REMQ-buffer)))
(+internal-rplachar-n si:STRING-REMQ-buffer j cc)
(setq j (1+ j))))))
;;;; Fill-in primitives
#+Multics
(defun MAKE-STRING (n)
(do ((s "" (catenate s ""))
(i n (- n 4)))
((< i 4)
(cond ((= i 0) s)
((catenate (cond ((= i 1) "")
((= i 2) "")
((= i 3) ""))
s))))))
#Q
(defun MAKE-STRING (n)
(let ((s (make-array () 'ART-16B n)))
(as-1 s STRING-CLASS 0)
s))
#-PDP10 (progn 'compile
(defun |STR/:STRING-POSQer| (foo char str &OPTIONAL (i* 0) (cnt 0 cntp))
(setq char (*:character-to-fixnum char))
(cond (cntp (|STR/:STRING-POSQ-Ner| foo char str i* cnt))
(#T (|STR/:STRING-POSQ-Ner| foo char str i*))))
(defun |STR/:STRING-POSQ-Ner| (foo char str &OPTIONAL (i* () i*p) (cnt () cntp)
&AUX (op (car foo))
(fwp (cdr foo)) )
(if (eq op 'FILL) (exch char str))
(cond (*RSET
(check-type char #'STR/:CHARACTER-VALUEP op)
(check-subsequence (str i* cnt) 'STRING op i*p cntp fwp)
(setq cntp #T i*p #T))
(#T (if (not i*p) (setq i* 0)) ))
(do ((n (cond (cntp cnt)
(fwp (- (string-length str) i*))
((1+ i*)))
(1- n))
(i i* (cond (fwp (1+ i)) ((1- i)))))
((= n 0) () )
(declare (fixnum n i))
(if (eq op 'FILL) (+internal-rplachar-n str i char)
(if (eq op (if (= char (+internal-char-n str i)) 'POSQ 'SKIPQ))
(return i)))))
) ;end of #-PDP10
;;;; PDP10 hooks - Methods for PRINT, EXPLODE, SXHASH, NAMESTRING, SAMEPNAMEP,
;;;; ALPHALESSP, LESSP, GREATERP, EQUAL, FLATSIZE, PURCOPY, USERATOMS
#+PDP10 (progn 'compile
(defmethod* (:PRINT-SELF STRING-CLASS) (str ofile () slashifyp)
(if *RSET (check-type str #'STRINGP ':PRINT-SELF->STRING-CLASS))
(setq ofile (si:normalize-stream ofile))
(if slashifyp (tyo #/" ofile))
(do ((len (string-length str))
(i 0 (1+ i))
(c 0))
((>= i len) )
(declare (fixnum len i c))
(setq c (+internal-char-n str i))
(and slashifyp (or (= c #/") (= c #//)) (tyo #// ofile))
(tyo c ofile))
(and slashifyp (tyo #/" ofile)))
(defmethod* (:PRINT-SELF CHARACTER-CLASS) (chr ofile () slashifyp)
(if *RSET (check-type chr #'CHARACTERP ':PRINT-SELF->CHARACTER-CLASS))
(setq ofile (si:normalize-stream ofile))
(cond (slashifyp (princ '|}//| ofile)))
(tyo (*:character-to-fixnum chr) ofile))
(defmethod* (EXPLODE STRING-CLASS) (str slashifyp number-p)
(if *RSET (check-type str #'STRINGP 'EXPLODE->STRING-CLASS))
(do ((strlist (and slashifyp
(if number-p (ncons #/") (ncons '/")))
(cons c strlist))
(len (string-length str))
(i 0 (1+ i))
(c 0))
((>= i len)
(if slashifyp (push (if number-p #/" '/") strlist))
(nreverse strlist))
(declare (fixnum len i))
(setq c (+internal-char-n str i))
(if (not number-p) (setq c (ascii c)))
(and slashifyp
(or (= c #/") (= c #//))
(push (if number-p #// '//) strlist))))
(defmethod* (EXPLODE CHARACTER-CLASS) (object slashify-p number-p)
(let ((result (cons #/}
(if slashify-p
(cons #//
(ncons (*:character-to-fixnum object)))
(ncons (*:character-to-fixnum object))))))
(if (not number-p) (mapcar 'ascii result) result)))
(defmethod* (SXHASH STRING-CLASS) (string) (string-hash string))
(defmethod* (NAMESTRING STRING-CLASS) (string)
(pnput (string-pnget string 7) () ))
(defmethod* (SAMEPNAMEP STRING-CLASS) (x y)
(si:alpha-test x y '(T . T) () ))
(defmethod* (ALPHALESSP STRING-CLASS) (x y)
(si:alpha-test x y '(T . () ) #T))
(defmethod* (LESSP STRING-CLASS) (x y)
(si:alpha-test x y '(T . () ) () ))
(defmethod* (GREATERP STRING-CLASS) (x y)
(si:alpha-test y x '(T . () ) () ))
(defun SI:ALPHA-TEST (x y foo alphalesspp)
(and (cond ((stringp x) (if (not (stringp y)) (setq y (get-pname y))))
((stringp y) (setq x (get-pname x)) #T)
(#T (+internal-lossage 'STRINGP 'ALPHALESSP->STRING-CLASS (list x y))))
alphalesspp
(error (/" |Mixed mode tests in an old lisp - ALPHALESSP|) (list x y)))
(str/:string-equal-lessp foo x y))
(defmethod* (EQUAL STRING-CLASS) (obj other-obj)
(and (stringp other-obj) (str/:compare-words obj other-obj)))
(DEFMETHOD* (FLATSIZE STRING-CLASS) (OBJ () () SLASHIFYP)
(DECLARE (FIXNUM MAX CNT))
(COND (SLASHIFYP
(DO ((MAX (1- (STRING-LENGTH OBJ)))
(I -1 (STRING-SEARCH-SET '(#/" #//) OBJ (1+ I)))
(CNT 2 (1+ CNT)))
((OR (NULL I) (= I MAX))
(+ CNT (COND (I (1+ MAX)) (MAX)))) ;Fix fencepost
))
(#T (STRING-LENGTH OBJ))))
(defmethod* (FLATSIZE CHARACTER-CLASS) (() () () slashifyp)
(if slashifyp 3 1))
(defmethod* (PURCOPY STRING-CLASS) (x)
(let ((nx (purcopy STR/:STRING-HUNK-PATTERN))
(nwds 1)
(str-len 0))
(declare (fixnum nwds str-len))
(and (cond ((not (stringp x)))
((< (setq str-len (string-length x)) 0))
((> (setq nwds (no-words-used str-len)) 512.)))
(error (/" |Can't PURCOPY a string this long|) x))
(let ((oni (nointerrupt #T)))
(if (< STR/:NO/.PWDSF nwds)
(setq STR/:PURE-ADDR (STR/:GRAB-PURSEG)
STR/:NO/.PWDSF 512.))
(setf (word-no nx) (purcopy (logior 1←35. (- (+ STR/:PURE-ADDR 512.)
STR/:NO/.PWDSF))))
(setq STR/:NO/.PWDSF (- STR/:NO/.PWDSF nwds))
(nointerrupt oni))
(setf (si:extend-class-of nx) (si:extend-class-of x))
(setf (si:extend-marker-of nx) (si:extend-marker-of x))
(setf (string-length nx) (purcopy str-len))
(if (> str-len 0) (string-replace nx x 0 0 str-len))
nx))
(defmethod* (DESCRIBE STRING-CLASS) (ob stream level)
(declare (special SI:DESCRIBE-MAX-LEVEL))
(if (and (not (> level SI:DESCRIBE-MAX-LEVEL))
(stringp ob))
(format stream
(/" |}%}vTThe string }S has }D characters.|)
level ob (string-length ob))))
(defmethod* (USERATOMS-HOOK STRING-CLASS) (x)
(list `(STRING-PNPUT ',(string-pnget x 7) #T)))
(defmethod* (USERATOMS-HOOK CHARACTER-CLASS) (x) ;; Don't macroexpand this - need the use of autoload properties
(list `(*:FIXNUM-TO-CHARACTER ,(*:character-to-fixnum x))))
) ;end of #+PDP10
;;;; Set up tables and constants
#M
(mapc #'(lambda (x) (set x (get x 'LSUBR)))
'(|STR/:STRING-SEARCHer| STR/:STRING-EQUAL-LESSP STR/:STRING-UP-DOWN-CASE
#-PDP10 |STR/:STRING-POSQ-Ner| #-PDP10 |STR/:STRING-POSQer| ))
#Q
(mapc '(lambda (x) (set x (fsymeval x)))
'(|STR/:STRING-POSQ-Ner| |STR/:STRING-POSQer|))
#+PDP10
(setq *FORMAT-STRING-GENERATOR 'TO-STRING)
#-NIL (progn 'compile
(setq |+internal-CHARACTER-table/||
(*array () 'T #.(1+ (↑ 2 *:bits-per-character))))
;;Fill in this table with the full 128. character objects,
;; for the ASCII alphabet, leaving a 129.th slot for a list
;; of folded-down 12-bit characters seen.
(do ((i #.(1- (↑ 2 *:bits-per-character)) (1- i))
(*RSET)
(z (and (status feature PDP10) (status nofeature ONESEGMENT))))
((< i 0))
(store (arraycall T |+internal-CHARACTER-table/|| i)
(if z
(new-character i T)
(new-character i))))
(defun |+internal-tilde-macro/|| #-LISPM () #Q (ignore ignore)
(let ((c (tyi)))
(declare (fixnum c))
(cond ((= c #//) (setq c (tyi))) ;Check for slash
((= c #/\) (setq c (/#-/\-parse))))
(*:fixnum-to-character c)))
#-LISPM (setsyntax '/} 'MACRO '|+internal-tilde-macro/||)
#Q (set-syntax-macro-char #/} '|+internal-tilde-macro/||)
#+PDP10 (progn 'compile
(def-or-autoloadable /#-/\-parse SHARPM)
(defun |+internal-doublequote-macro/|| ()
(declare (fixnum ln i c))
(do ((c (tyi) (tyi))
(charsl))
((= c #/")
(let* ((ln (length charsl))
(str (make-string ln)))
(declare (fixnum ln))
(do ((i 0 (1+ i)))
((>= i ln))
(declare (fixnum i))
(+internal-rplachar-n str (- ln i 1) (pop charsl)))
str))
(push (if (= c #//) (tyi) c) charsl)))
(setsyntax '/" 'MACRO '|+internal-doublequote-macro/||)
) ;end of #+PDP10
) ;end of #-NIL
(mapc '(lambda (x) (putprop x '|mmcdrside/|| '|side-effectsp/||))
'(CHAR CHAR-N +INTERNAL-CHAR-N CHARACTERP
*:CHARACTER-TO-FIXNUM *:FIXNUM-TO-CHARACTER
TO-CHARACTER TO-CHARACTER-N TO-CHARACTER-N?
TO-STRING DIGITP DIGIT-WEIGHT
CHARACTER CHAR-EQUAL CHAR-LESSP GET-PNAME STRING-REMQ
MAKE-STRING STRING-SEARCHQ STRING-BSEARCHQ STRING-MISMATCHQ
STRING-POSQ STRING-BPOSQ STRING-POSQ-N STRING-BPOSQ-N
STRING-SKIPQ STRING-BSKIPQ STRING-SKIPQ-N STRING-BSKIPQ-N
STRING-EQUAL STRING-LESSP STRING-SEARCH STRING-REVERSE-SEARCH
STRING-DOWNCASE STRING-UPCASE CHAR-DOWNCASE CHAR-UPCASE
STRING-REVERSE SUBSTRING STRING-APPEND STRING-SUBSEQ
STRING-SEARCH-CHAR STRING-SEARCH-NOT-CHAR
STRING-SEARCH-SET STRING-SEARCH-NOT-SET
STRING-REVERSE-SEARCH-CHAR STRING-REVERSE-SEARCH-NOT-CHAR
STRING-REVERSE-SEARCH-SET STRING-REVERSE-SEARCH-NOT-SET
STRING-PNGET STRING-PNPUT STRING-HASH
) )
#+PDP10
(setq GC-DAEMON
(cond ((null GC-DAEMON) 'STR/:GC-DAEMON)
((let ((g (gensym))
(h (cond ((or (symbolp gc-daemon)
(and (not (atom gc-daemon))
(eq (car gc-daemon) 'LAMBDA)))
`(,gc-daemon))
(`(FUNCALL ',gc-daemon)))))
`(LAMBDA (,g)
(STR/:GC-DAEMON ,g)
(,.H ,g))))))
(sstatus feature STRING)
ββββ